home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / sml_nj / 93src.lha / src / cps / schedule.sml < prev    next >
Encoding:
Text File  |  1993-01-27  |  6.8 KB  |  211 lines
  1. (* schedule.sml
  2.  *
  3.  * COPYRIGHT (c) 1991 by AT&T Bell Laboratories
  4.  *)
  5.  
  6. structure Schedule : sig
  7.     val schedule: CPS.function -> CPS.function
  8.   end = struct
  9.  
  10. open CPS Access
  11. val uniq = SortedList.uniq
  12.  
  13. val say = System.Print.say
  14.  
  15. fun sublist test =
  16.   let fun subl(a::r) = if test a then a::(subl r) else subl r
  17.         | subl [] = []
  18.   in  subl
  19.   end
  20.  
  21. fun member l = let fun f(i,j::rest) = i=j orelse f(i,rest) | f(_,nil) = false
  22.                 in fn i => f(i,l)
  23.            end
  24.  
  25. fun sum f (i::r) = f i + sum f r | sum f nil = 0
  26.  
  27. fun all pred = 
  28.       let fun f nil = true | f(i::rest) = pred i andalso f rest in f end
  29.  
  30. type child = {path: int list,
  31.           branches: int,
  32.           uses: lvar list,
  33.           defs: lvar list,
  34.           make: cexp list -> cexp}
  35.  
  36. fun show nil = say "."
  37.   | show (v::vl) = (say(makestring(v:int)); say ","; show vl)
  38.  
  39. fun showl nil = say "]"
  40.   | showl [x] = (say(makestring(x:int)); say "]")
  41.   | showl (x::rest) = (say(makestring(x:int)); say "."; showl rest)
  42.               
  43.  
  44. fun showc (({defs=nil,path,...}:child)::vl) =
  45.       (say "["; showl path; say "branch,"; showc vl)
  46.   | showc ({defs=w::_,path,...}::vl) =
  47.       (say "["; showl path; say(makestring w); say ","; showc vl)
  48.   | showc nil = say "."
  49.  
  50. fun schedule(f,vl,cexp) =
  51. let 
  52.     val _ = if !System.Control.CG.printit
  53.           then(say "\nBefore:\n\n"; CPSprint.show say cexp)
  54.           else ()
  55.         
  56.     exception Schedmap
  57.     val m : child list Intmap.intmap = Intmap.new(32,Schedmap)
  58.     val addm = Intmap.add m
  59.     val getm = Intmap.map m
  60.  
  61.     fun def w = addm(w, nil)
  62.  
  63.     val mem0 = mkLvar()
  64.     val done0 = mem0::vl
  65.     val _ = app def done0
  66.  
  67.     val biglist : child list ref = ref nil
  68.  
  69.     fun enter(path,mem,e) = 
  70.     let 
  71.         fun vars(VAR v :: rest) = v::(vars rest)
  72.           | vars(_ :: rest) = vars rest
  73.           | vars nil = nil
  74.  
  75.             fun note(child as {path,branches,uses,defs,make}) =
  76.             (app (fn v => addm(v, child :: getm v)) uses;
  77.              app def defs;
  78.              biglist := child :: !biglist)
  79.  
  80.         fun usedef(uses,defs,c,make) = 
  81.         (note{path=path,branches=1,uses= uniq(vars uses),
  82.               defs=defs,make=make};
  83.          enter(path,mem,c))
  84.    
  85.         fun storeop (p,args,res,[c]) =
  86.          let val m = mkLvar()
  87.          in note{path=path,branches=1,
  88.                          uses= uniq(vars(VAR mem :: args)),
  89.              defs=res@[m], make=fn cl=>PRIMOP(p,args,res,cl)};
  90.             enter(path,m,c)
  91.          end
  92.  
  93.         fun fetchop(p,args,res,[c]) = 
  94.           usedef(VAR(mem)::args, res, c, fn cl=>PRIMOP(p,args,res,cl))
  95.  
  96.         fun branch(vl,cl,make) =
  97.         let fun f(i,c::cl) = (enter(path@[i],mem,c); f(i+1, cl))
  98.                     | f _ = ()
  99.         in note{path=path,branches=length cl,uses= uniq(vars vl),
  100.             defs=[], make=make};
  101.            f(0,cl)
  102.                 end
  103.  
  104.      in case e 
  105.          of SELECT(i,v,w,c) => usedef([v],[w],c, fn[c]=>SELECT(i,v,w,c))
  106.           | OFFSET(i,v,w,c) => usedef([v],[w],c, fn[c]=>OFFSET(i,v,w,c))
  107.           | RECORD(k,l,w,c) => usedef(map #1 l, [w], c, fn[c]=>RECORD(k,l,w,c))
  108.           | APP(v,vl) => branch(VAR(mem)::v::vl, nil, fn _ => e)
  109.               | PRIMOP(args as (P.store,_,_,_)) => storeop args
  110.               | PRIMOP(args as (P.update,_,_,_)) => storeop args
  111.               | PRIMOP(args as (P.boxedupdate,_,_,_)) => storeop args
  112.               | PRIMOP(args as (P.unboxedupdate,_,_,_)) => storeop args
  113.               | PRIMOP(args as (P.sethdlr,_,_,_)) => storeop args
  114.                  (* the following are storeops because they
  115.                 may raise exceptions.  How annoying. *)
  116.               | PRIMOP(args as (P.*,_,_,_)) => storeop args
  117.               | PRIMOP(args as (P.+,_,_,_)) => storeop args
  118.               | PRIMOP(args as (P.-,_,_,_)) => storeop args
  119.               | PRIMOP(args as (P.div,_,_,_)) => storeop args
  120.               | PRIMOP(args as (P.fadd,_,_,_)) => storeop args
  121.  
  122. (* still to implement:  
  123.       floor | round | real | subscriptf | updatef | unboxed lessu gequ *)
  124.               | PRIMOP(args as (P.fdiv,_,_,_)) => storeop args
  125.               | PRIMOP(args as (P.fmul,_,_,_)) => storeop args
  126.               | PRIMOP(args as (P.fsub,_,_,_)) => storeop args
  127.               | PRIMOP(args as (P.~,_,_,_)) => storeop args
  128.  
  129.           | PRIMOP(args as (P.!, _,_,_)) => fetchop args
  130.           | PRIMOP(args as (P.ordof, _,_,_)) => fetchop args
  131.           | PRIMOP(args as (P.subscript, _,_,_)) => fetchop args
  132.           | PRIMOP(args as (P.gethdlr, _,_,_)) => fetchop args
  133.           | PRIMOP(p,vl,res,[c]) => usedef(vl,res,c, 
  134.                            fn cl=>PRIMOP(p,vl,res,cl))
  135.           | SWITCH(v,cl) => branch([v],cl, fn cl=>SWITCH(v,cl))
  136.           | PRIMOP(p,vl,[],cl) => branch(vl,cl, fn cl=>PRIMOP(p,vl,[],cl))
  137.           | PRIMOP(_,vl,_,_) => ErrorMsg.impossible "8223 in schedule"
  138.           | _ => ErrorMsg.impossible "8224 in schedule"
  139.      end
  140.  
  141.      val _ = enter(nil,mem0,cexp)
  142.  
  143.    fun prefix(nil,_) = true
  144.      | prefix((i:int)::i', j::j') = i=j andalso prefix(i',j')
  145.      | prefix _ = false
  146.  
  147.    fun proper_prefix(nil,_::_) = true
  148.      | proper_prefix((i:int)::i', j::j') = i=j andalso proper_prefix(i',j')
  149.      | proper_prefix _ = false
  150.  
  151.      fun isready done ({uses,...}:child) = all (member done) uses
  152.      fun newly_ready(done,nil) = nil
  153.        | newly_ready(done,w::rest) =
  154.               sublist (isready(w::done)) (getm w) @ 
  155.           newly_ready(w::done, rest)
  156.  
  157.      fun sched(path, done, ready) =
  158.       let 
  159.       val _ = if !System.Control.CG.printit
  160.                then (say "\nDone= "; show done;
  161.            say "\nReady = "; showc ready) else ()
  162.             
  163.       fun howgood {path=p0,branches,uses,defs,make} =
  164.           let fun f v = let fun count(({defs=nil,...}:child)::rest) = 
  165.                                 count rest
  166.                   | count({path=p,defs as w::_,...}::rest) = 
  167.                     if prefix(path,p)
  168.                          andalso not(member done w) 
  169.                     then 1 + count rest
  170.                         else count rest
  171.                   | count nil = 0
  172.                 in 100 quot count(getm v) handle Div => 100
  173.                 end
  174.           in if prefix(p0,path)
  175.            then sum f uses - 100*length defs
  176.                - (if branches=1 then 0 else 1000)
  177.            else ~10000
  178.           end
  179.  
  180.           fun bestl(~10000, choice, nil,others) = 
  181.               ErrorMsg.impossible "765 in schedule"
  182.         | bestl(goodness, choice, nil,others) = (choice,others)
  183.         | bestl(g, ch, r::rest, others) = 
  184.           let val g' = howgood r
  185.            in if g'>g then bestl(g',r,rest,ch::others)
  186.                   else bestl(g,ch,rest,r::others)
  187.           end
  188.       fun best(a::rest) = bestl(howgood a, a, rest, nil)
  189.         | best nil = ErrorMsg.impossible "1234 in schedule"
  190.  
  191.        in case best ready
  192.        of ({defs, branches=1, make,...}, rest) =>
  193.               make[sched(path, defs@done, newly_ready(done,defs) @ rest)]
  194.         | ({defs=nil, branches, make,...}, rest) =>
  195.           let fun f i = if i<branches 
  196.                     then sched(path@[i],done,rest)::f(i+1)
  197.                     else nil
  198.            in make(f 0)
  199.           end
  200.         | _ => ErrorMsg.impossible "1133 in schedule"
  201.       end
  202.             
  203.     val cexp = sched(nil, done0, sublist (isready done0) (!biglist))
  204.     val _ = if !System.Control.CG.printit
  205.           then(say "\nAfter:\n\n"; CPSprint.show say cexp)
  206.           else ()
  207.   in (f,vl,cexp)
  208.  end
  209.  
  210. end
  211.